home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #102 (1990-12)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #102 (1990-12)(Amiga User Group Deutschland e.V.).adf / Architekt / Architekt (.txt) < prev    next >
AmigaBASIC Source Code  |  1989-07-03  |  10KB  |  346 lines
  1.  '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  2.  '                                                                 +
  3.  'Detlef Kornatz                                                   +
  4.  'Feuerbachstrasse 6                                               +
  5.  'D-4300 ESSEN 1                                                   +
  6.  '                                                                 +
  7.  '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  8.  
  9. SCREEN 2,320,270,5,1
  10. WINDOW 2,"           HAUSGRUNDRISS ",,0,2
  11.   PALETTE 29,0,0,0
  12.   PALETTE 0,0.69,0.69,0.98       
  13.   PALETTE 1,0.2,0.2,0.2   
  14.   PALETTE 2,0.1,0.9,0.9      
  15.   PALETTE 3,0.93,0.2,0   
  16.   PALETTE 4,1,0.4,0     
  17.   PALETTE 5,1,0.6,0     
  18.   PALETTE 6,1,0.8,0     
  19.   PALETTE 7,1,1,0     
  20.   PALETTE 8,0.6,1,0.15   
  21.   PALETTE 9,0.5,0.8,0.15  
  22.   PALETTE 10,0.4,0.6,0   
  23.   PALETTE 11,0.2,0.4,0   
  24.   PALETTE 12,0,0.4,0    
  25.   PALETTE 13,0,0.6,0.67  
  26.   PALETTE 14,0,0.8,0.6   
  27.   PALETTE 15,0,1,0.6   
  28.   PALETTE 16,0.2,1,0.93  
  29.   PALETTE 17,0.2,0.75,1  
  30.   PALETTE 18,0.15,0.4,1  
  31.   PALETTE 19,0.4,0,1    
  32.   PALETTE 20,0,0,0.6    
  33.   PALETTE 21,0.35,0.15,0.8
  34.   PALETTE 22,0.6,0.2,1   
  35.   PALETTE 23,1,0,1     
  36.   PALETTE 24,0.9,0.5,0.75 
  37.   PALETTE 25,1,0.75,0.75 
  38.   PALETTE 26,0.8,0.55,0.5 
  39.   PALETTE 27,0.6,0.4,0.35 
  40.   PALETTE 28,0.4,0.2,0     
  41.   PALETTE 30,0.6,0.6,0.6   
  42.   PALETTE 31,0.7,0.7,0.7 
  43.     
  44.    CLEAR ,40000                
  45.    DIM bau(110,20)  
  46.    w=1:mx=-1:my=0
  47.    FOR ein=1 TO 20
  48. ON ein GOSUB radier,mauer1,mauer2,mauer3,mauer4,kreuz,mauer5,mauer6,mauer7,mauer8,mauer9,mauer10,treppe1,treppe2,balkeno,eckelu,eckero,eckeol,eckeur,tischgr
  49.    GET(0,0)-(19,19),bau(110,ein-1)
  50.    CLS               
  51.    NEXT
  52.    GOSUB Rahmen : GOSUB bauen   
  53. retur:
  54.    MENU ON
  55.    WHILE MOUSE(0) = 0                   
  56.    x = MOUSE(1): y = MOUSE(2)
  57.    IF y<200 THEN
  58.    PUT(x-10,y-5),bau(110,w)
  59.    PUT(x-10,y-5),bau(110,w)
  60.    END IF
  61.    WEND       
  62.    IF x> = 300 THEN retur                
  63.    IF y> = 200 THEN GOTO taste
  64. kleber:                             
  65.    x = FIX (x/20): y = FIX(y/20)
  66.    x = x*20: y = y*20
  67.    IF w = 19 AND mx<>-1 THEN PUT(mx,my),bau(110,19)
  68.    IF x = mx AND y = my THEN mx = -1
  69.    IF w<19 THEN PUT(x,y),bau(110,w),PSET :ELSE PUT(x,y),bau(110,19)
  70.    mx = x: my = y
  71.    GOTO retur
  72.    '**************************************************
  73. taste:                           
  74.    rx = MOUSE(1)                               
  75.    rx = FIX(rx/20): y = FIX(y/20): y = y*20
  76.    IF y = 200 THEN w = rx
  77.    IF y = 220 AND rx<5 THEN w = 15+rx 
  78.    IF y = 220 AND rx> = 5 THEN druecke
  79.    a = MOUSE(0) 
  80.    GOTO retur
  81.  
  82. druecke:
  83.     rx = MOUSE(1)                              
  84.     IF rx <160 AND rx >120 THEN sauber
  85.     IF rx <220 AND rx >180 THEN GOSUB screenDump
  86.     IF rx <280 AND rx >240 THEN GOTO ende
  87.   '*************+++++++++++++++++**************************      
  88. sauber:
  89.     LINE (1,1)-(298,198),0,bf
  90.     LINE(0,0)-(299,199),3,b 
  91.     GOTO retur
  92.     
  93. bauen:
  94.   FOR a = 0 TO 14                     
  95.   x = a*20
  96.   PUT (x,202), bau(110,a),PSET
  97.   NEXT
  98.   FOR a = 15 TO 19
  99.   x =  a*20-300
  100.   PUT (x,222), bau(110,a),PSET
  101.   NEXT
  102.       LINE (120,226)-(160,245),12,bf
  103.       CALL tool (130,230):COLOR 7,12:LOCATE 30,17:PRINT "NEU"
  104.       LINE (180,226)-(230,245),12,bf
  105.       CALL tool (190,230):COLOR 7,12:LOCATE 30,24:PRINT "DRUCK"
  106.       LINE (240,226)-(290,245),12,bf
  107.       CALL tool (265,230):COLOR 7,12:LOCATE 30,32:PRINT "ENDE"
  108.   RETURN 
  109. Rahmen:
  110.    l=1:h=1
  111.    COLOR 20,0
  112.    LOCATE 3,2:PRINT "Geben Sie bitte die Grundfläche ein."
  113.    LOCATE 6,2:PRINT "Mindestmaße 15 m * 10 m"
  114.    LOCATE 9,12:  INPUT"Länge   ";l            ' Länge
  115.    LOCATE 12,12:  INPUT"Breite  ";h           ' Breite
  116.    CLS
  117.    IF l > 16 THEN GOTO Rahmen
  118.    IF h > 11 THEN GOTO Rahmen
  119.    IF l< 16 THEN a = 299
  120.    IF h< 11 THEN b = 199
  121.    LINE(0,0)-(a,b),3,b                
  122.    e=1 :f=1
  123.    FOR x = 0 TO a STEP (a-0)/l         
  124.    LINE (x,e-2) - (x,e+3),3
  125.    NEXT x   
  126.    FOR y = 0 TO b STEP (b-0)/h         
  127.    LINE (f-2,y) - (f+3,y),3
  128.    NEXT y
  129.    LINE (0,0)-(a,b),3,b 
  130.    COLOR 20,0:LOCATE 2,34:PRINT l     
  131.    COLOR 20,0:LOCATE 24,1:PRINT h   
  132.    SUB tool(c%,d%) STATIC
  133.    xa&=WINDOW(8)+36:ya&=WINDOW(8)+38
  134.    POKEW xa&,c%
  135.    POKEW ya&,d%
  136.    END SUB
  137.   
  138. radier:
  139.    LINE (0,0)-(20,20),0,bf
  140.    RETURN
  141.  
  142. mauer1:
  143.    LINE (0,13)-(19,19),21,b
  144.    RETURN
  145.  
  146. mauer2:
  147.    LINE (0,0)-(19,6),21,b
  148.    RETURN
  149. mauer3:
  150.    LINE (0,0)-(6,19),21,b
  151.    RETURN
  152. mauer4:
  153.    LINE (13,0)-(19,19),21,b
  154.    RETURN
  155. kreuz:
  156.    LINE (0,6)-(19,13),21,b
  157.    LINE (6,0)-(13,19),21,b
  158.    LINE (6,6)-(13,13),0,bf
  159.    RETURN
  160. mauer5:
  161.   LINE (0,6)-(19,13),21,b 
  162.   RETURN
  163. mauer6:
  164.   LINE (6,0)-(13,19),21,b
  165.   RETURN
  166. mauer7:
  167.   LINE (0,0)-(19,6),21,b
  168.   LINE (6,6)-(13,19),21,b
  169.   RETURN  
  170. mauer8:
  171.   LINE (0,13)-(19,19),21,b
  172.   LINE (6,0)-(13,13),21,b
  173.   RETURN
  174. mauer9:
  175.   LINE (0,0)-(6,19),21,b
  176.   LINE (6,6)-(19,13),21,b
  177.   RETURN
  178. mauer10:
  179.   LINE (13,0)-(19,19),21,b
  180.   LINE (0,6)-(13,13),21,b
  181.   RETURN
  182. treppe1:
  183.   LINE (0,1)-(19,5),21,b  
  184.   LINE (0,8)-(19,12),21,b
  185.   LINE (0,15)-(19,19),21,b
  186.   RETURN
  187. treppe2:
  188.   LINE (1,0)-(5,19),21,b
  189.   LINE (8,0)-(12,19),21,b
  190.   LINE (15,0)-(19,19),21,b
  191.   RETURN
  192. balkeno:
  193.   LINE (0,0)-(19,6),21,b
  194.   LINE (0,13)-(19,19),21,b
  195.   LINE (0,6)-(6,13),21,b
  196.   LINE (13,6)-(19,13),21,b
  197.   RETURN  
  198. eckelu:
  199.   LINE (0,0)-(6,19),21,b
  200.   LINE (6,13)-(19,19),21,b  
  201.   RETURN
  202. eckero:
  203.   LINE (0,0)-(19,6),21,b
  204.   LINE (13,6)-(19,19),21,b  
  205.   RETURN
  206. eckeur:
  207.   LINE (0,0)-(19,6),21,b
  208.   LINE (0,6)-(6,19),21,b
  209.   RETURN
  210. eckeol:
  211.   LINE (0,13)-(19,19),21,b
  212.   LINE (13,0)-(19,13),21,b
  213.   RETURN
  214. tischgr:
  215.    LINE (0,0)-(10,0),0
  216.   RETURN
  217.   
  218. screenDump:
  219. LINE (0,200)-(300,260),0,bf
  220.  
  221. IF AlreadyDeclared = 0 THEN
  222.  DECLARE FUNCTION AllocSignal%() LIBRARY
  223.  DECLARE FUNCTION AllocMem&()    LIBRARY
  224.  DECLARE FUNCTION FindTask&()    LIBRARY
  225.  DECLARE FUNCTION DoIO&()        LIBRARY
  226.  DECLARE FUNCTION OpenDevice&    LIBRARY
  227.  AlreadyDeclared = 1
  228. END IF
  229.  
  230. sWindow&   = WINDOW(7)
  231. sScreen&   = PEEKL(sWindow& + 46)
  232. sViewPort& = sScreen& + 44
  233. sRastPort& = sScreen& + 84
  234. sColorMap& = PEEKL(sViewPort& + 4)
  235.  
  236.  
  237. maxWidth%  = PEEKW(sScreen& + 12)
  238. maxHeight% = PEEKW(sScreen& + 14)        
  239. viewModes% = PEEKW(sViewPort& + 32)
  240.  
  241. command%  = 11   'Drucker-Befehls-Nummer
  242. srcX% = 0        'Sende ganzen Screen
  243. srcY% = 0 
  244. srcWidth%  = maxWidth%
  245. srcHeight% = maxHeight%
  246. destRows& = 0    
  247. destCols& = 0
  248. special% = &H84  'FullCol | Aspect
  249.  
  250. IF BorderFlag% = 0 THEN  'Kein Rahmen
  251.    srcX% = srcX% + 3
  252.    srcY% = srcY% + 11
  253.    srcWidth%  = srcWidth% - 3 - 11
  254.    srcHeight% = srcHeight% - 11 - 3
  255. END IF   
  256.  
  257. LIBRARY "exec.library"
  258.  
  259.  
  260. sigBit% =  AllocSignal%(-1)
  261. ClearPublic& = 65537
  262. msgPort& = AllocMem&(40,ClearPublic&)
  263. IF msgPort& = 0 THEN
  264.    PRINT "msgPort nicht allokierbar."
  265.    GOTO cleanup4
  266. END IF
  267.  
  268.  
  269. POKE(msgPort& + 8), 4 'Type=NT_MSGPORT
  270. POKE(msgPort& + 9), 0 'Priority 0 
  271. portName$ = "MyPrtPort"+CHR$(0)
  272. POKEL(msgPort& + 10), SADD(portName$)
  273. POKE(msgPort& + 14), 0 'Flags
  274. POKE(msgPort& + 15), sigBit%
  275. sigTask& = FindTask&(0)
  276. POKEL(msgPort& + 16), sigTask&
  277.  
  278. CALL AddPort(msgPort&)  'Port hinzufuegen
  279.  
  280.  
  281. ioRequest& = AllocMem&(64,ClearPublic&)
  282. IF ioRequest& = 0  THEN
  283.    PRINT "ioRequest nicht allokierbar."
  284.    GOTO cleanup3
  285. END IF
  286.  
  287. POKE(ioRequest& + 8),5 'Type=NT_MESSAGE
  288. POKE(ioRequest& + 9),0 'Priority 0
  289. POKEL(ioRequest& + 14), msgPort&
  290.  
  291.  
  292. devName$ = "printer.device"+CHR$(0)
  293. pError& = OpenDevice&(SADD(devName$),0,ioRequest&,0)
  294. IF pError& <> 0  THEN
  295.    PRINT "Drucker nicht ansprechbar."
  296.    GOTO cleanup2
  297. END IF
  298.  
  299.  
  300. POKEW(ioRequest& + 28), command%
  301. POKEL(ioRequest& + 32), sRastPort&
  302. POKEL(ioRequest& + 36), sColorMap&
  303. POKEL(ioRequest& + 40), viewModes%
  304. POKEW(ioRequest& + 44), srcX%
  305. POKEW(ioRequest& + 46), srcY%
  306. POKEW(ioRequest& + 48), srcWidth%
  307. POKEW(ioRequest& + 50), srcHeight%
  308. POKEL(ioRequest& + 52), destCols&
  309. POKEL(ioRequest& + 56), destRows&
  310. POKEW(ioRequest& + 60), special%
  311.  
  312. ioError& = DoIO&(ioRequest&)
  313. IF ioError& <> 0 THEN
  314.    PRINT "DumpRPort Fehler =" ioError&
  315.    GOTO cleanup1
  316. END IF
  317.  
  318. cleanup1:
  319.    REM  *** Close Printer Device ***
  320.    CALL CloseDevice(ioRequest&)
  321.  
  322. cleanup2:
  323.    REM  *** DeleteExtIO ***
  324.    POKE(ioRequest& + 8), &Hff
  325.    POKEL(ioRequest& + 20), -1
  326.    POKEL(ioRequest& + 24), -1
  327.    CALL FreeMem(ioRequest&,64)
  328.  
  329. cleanup3:
  330.    REM  *** DeletePort ***
  331.    CALL RemPort(msgPort&)
  332.    POKE(msgPort& + 8), &Hff  
  333.    POKEL(msgPort& + 20), -1
  334.    CALL FreeSignal(sigBit%)
  335.    CALL FreeMem(msgPort&,40)
  336.    
  337. cleanup4:
  338.    
  339.    LIBRARY CLOSE  
  340. END      
  341. ende:
  342. WINDOW CLOSE 2:SCREEN CLOSE 2
  343. SYSTEM   
  344. END
  345.  
  346.